Optional Images.f

{ TODO

testing
grab framebuffer

}

Requires SDL
Requires Linked-Lists
Requires SORA/Surfaces
Requires DevIL
Requires SEKI
Requires OpenGL\EXT-FBO

only forth definitions
also sdl-surfaces

/Node Inherit
   cell field ->source-image     \ file in memory
   cell field ->texture
   cell field ->texture-x     \ offset that has been applied to subimages
   cell field ->texture-y
   cell field ->image-w     \ dims of the surface
   cell field ->image-h
   cell field ->texture-w     \ dims of the texture
   cell field ->texture-h
   cell field ->fbo           \ framebuffer object
   cell field ->dbrb           \ depthbuffer renderbuffer
   2 cells field ->subimages
   cell field ->surface
End-struct /Image

Create Images /Node /allot
\ =========================================================
\ Textures

: init-texture
   dup  ->surface @  sdl-copy  prepare-surface  dup  >r  sdl-texture  over ->texture !
   r@ sdl-dims  rot ->texture-w 2v!  r> sdl-destroy  ;
   \ dup  ->surface @  sdl-texture  swap  ->texture !  ;

: update-texture   ( image rect -- )
   >r  dup  ->surface @  swap  ->texture @   r>  swap  sdl-update-texture  ;

\ =========================================================
\ Palettes

: Palette:  ( -- <name> )
   create 256 0 do $deadbeef , loop ;

: save-palette  ( palette filename count -- )
   rot locals| palette |
   file:[  empty-file  palette  256 cells  rot  write-file  throw  ;] ;

: load-palette  ( filename count palette -- )
   -rot  file:[  read-file  throw  drop  ;]  ;

\ =========================================================
\ Loading/Saving support

-? 0 value S

\ Creates a temporary DevIL image, deleting it after the quotation is finished.
:[] il:[   ( xt -- ) ( il-image -- )
   ilInit ilGenImage dup >q ilBindImage catch q> ilDeleteImage throw ilShutDown ;

: il-dims   IL_IMAGE_WIDTH ilGetInteger IL_IMAGE_HEIGHT ilGetInteger ;

: surface>il  ( surface -- success? )
   dup >r sdl-dims 1 4 IL_BGRA IL_UNSIGNED_BYTE  r> 0 0 sdl-pixel ilTexImage ;

: sdl-ilformat
   dup sdl-has-alpha? IF
      sdl-red-first? IF IL_RGBA ELSE IL_BGRA THEN
   ELSE
      sdl-red-first? IF IL_RGB ELSE IL_BGR THEN
   THEN ;

: il-load-lump
   2dup 2>r ilDetermineTypeL 2r> ilLoadL 0= abort" Error loading image from memory. (DevIL)" ;

: il-create-surface
   IL_PAL_RGBA32 ilConvertPal 0= abort" Error converting palette. (DevIL)"
   il-dims sdl-new to S
   ilCopyPixels(  0  0  0  il-dims   1  IL_BGRA  IL_UNSIGNED_BYTE  S 0 0 sdl-pixel ) drop ;

: load-surface  ( filename count -- surface )
   z$ locals| filename |
   il:[
      filename ilLoadImage 0= abort" Error loading image from file. (DevIL)"
      il-create-surface
   ;] S ;

: load-surface&palette  ( filename count palette -- surface )
   -rot z$ locals| filename palette |
   il:[
      filename ilLoadImage 0= abort" Error loading image from file. (DevIL)"
      il-create-surface
      ilGetPalette  ( dup mem )  palette  256  cells  move
   ;] S ;

\ Bit-depths 8 and 32 are supported
: save-surface ( surface bitdepth filename count -- )
   z$ locals| filename bitdepth S |
   il:[
      S surface>il 0=
         abort" Error converting surface to image for saving. (DevIL)"
      bitdepth 8 = if
         ilConvertImage( IL_COLOR_INDEX IL_UNSIGNED_BYTE )
            0= abort" Error converting image before saving. (DevIL)"
         ilConvertPal( IL_PAL_RGBA32 )
            0= abort" Error converting palette. (DevIL)"
      else ilConvertImage( IL_RGBA IL_UNSIGNED_BYTE )
            0= abort" Error converting image before saving. (DevIL)"
      then
      ilHint( IL_USE_COMPRESSION IL_COMPRESSION_HINT )
      \ Not sure if this is always needed, but so far BMP, PNG, and JPG all required it... maybe it's something else that I'm doing????
         iluFlipImage
      filename zcount delete-file drop
      filename ilSaveImage
         0= abort" Error saving image. Maybe the file is locked. (DevIL)"
   ;] ;

\ =========================================================
\ Loading/Saving

: load-image  ( filename count image -- )
   >r load-surface r> ->surface ! ;

: load-image&palette  ( filename count image palette -- )
   swap >r load-surface&palette r> ->surface ! ;

: save-image  ( image filename count bitdepth -- )
   locals| bd cnt fn |
   ->surface @ bd fn cnt save-surface ;

\ =========================================================
{
: new-image
   /Image allocate throw

: destroy-image

: forget-image
   dup ->surface @ sdl-destroy
   ->texture @ free-texture ;

: copy-image  ( image1 -- image2 )
   dup forget-image
   swap ->surface @ sdl-copy swap ->surface ! ;
}

\ =========================================================
\ Drawing

\ Defines how much space the value of 1 maps to on a texture when specify texture coordinates
\  It's OK to use either fixed point or integers here, so long all the parameters given are the same type.
: texture-granularity  ( granx grany texw texh -- )
   tm-identity   swap  glscaled(  1e .>f f/ swap .>f f*   1e .>f f/ .>f f*   1e ) ;

: bind-image-texture  ( granx grany image -- )
   dup  ->texture  @  bind-texture   ->texture-w 2v@  texture-granularity ;

: bind-image  ( image -- )
   1 1 rot bind-image-texture ;

\ =========================================================
\ Subimages

\ Subimages format:
\  x , y , w , h , origin-x , origin-y , x-stride (for fonts) , char# (for fonts) , (all 16bit signed half's)
\                                        delay (for sprites) , jump (for sprites)
16 constant /Subimage

: Subimages:  ( image -- )
   here  swap  ->subimages  !  ;

: subimage[]  ( n image -- addr )
   ->subimages @ swap  /Subimage  *  +  ;

\ really it's the size of the texture (since right now it's the size of the surface)...
: image@dims ( image -- w h )   ->texture-w 2v@ ; \ ->surface @ sdl-dims ;
: image@width  image@dims drop ;
: image@height  image@dims nip ;

\ Subimage properties
:macro @origin   8 + 2h@ ;

\ For font symbols
:macro @xstride   12 + h@ ;

\ For sprites
:macro @delay  12 + h@ ;
:macro @next  14 + h@ ;

\ =========================================================
\ Init support

: init-image
   dup ->source-image @ ?dup 0= if drop exit then
   cache-count locals| size lump |
   il:[ lump size il-load-lump il-create-surface ;]
   S sdl-dims third ->image-w 2v!
   S sdl-make-32bit sdl-colorkey-alpha swap ->surface ! ;
   \ S prepare-surface swap ->surface ! ;

: free-image
   ->surface @ sdl-destroy ;

: revert-image
   free-image  init-image ;


\ =========================================================
\ Framebuffers

: bind-fbo  ( fbo -- )
   glBindFramebufferEXT( GL_FRAMEBUFFER_EXT  swap ) ;

: unbind-fbo  ( -- )
   glBindFramebufferEXT( GL_FRAMEBUFFER_EXT  0 ) ;

: verify-fbo
   bind-fbo
   GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
   cr GL_FRAMEBUFFER_COMPLETE_EXT <> if ." FBO not complete " else ." FBO OK!" then
   unbind-fbo ;

: resize-image  ( image w h -- )
   2>r  dup ->surface @ dup  2r>  sdl-resize
   swap  sdl-destroy
   swap  ->surface !  ;

: make-framebuffer ( w h image -- )
   locals| image |
   image -rot resize-image
   \ Framebuffer
   glGenFramebuffersEXT( 1  image ->fbo )
   glBindFramebufferEXT( GL_FRAMEBUFFER_EXT  image ->fbo @ )
   glFramebufferTexture2DEXT( GL_FRAMEBUFFER_EXT  GL_COLOR_ATTACHMENT0_EXT  GL_TEXTURE_2D  image ->texture @  0 )
   \ for depth buffer support
   glGenRenderbuffersEXT( 1  image ->dbrb )
   glBindRenderbufferEXT( GL_RENDERBUFFER_EXT  image ->dbrb @ )
   glRenderbufferStorageEXT( GL_RENDERBUFFER_EXT  GL_DEPTH_COMPONENT24  image ->texture-w 2v@  )
   glFramebufferRenderbufferEXT( GL_FRAMEBUFFER_EXT  GL_DEPTH_ATTACHMENT_EXT  GL_RENDERBUFFER_EXT  image ->dbrb @ )
   cr ." Checking image FBO..." image ->fbo @ verify-fbo
   unbind-fbo ;

: free-framebuffer ( image -- )
   glDeleteFramebuffersEXT( 1  swap ->fbo ) ;

\ : grab-framebuffer

: bind-framebuffer ( image -- )
   dup ->fbo @ bind-fbo
   glPushAttrib( GL_VIEWPORT_BIT )
   glViewport(  0  0  rot ->image-w 2v@  )
   ;

\ special 2D projection mode for framebuffer objects - puts things rightside up
: framebuffer-2dmode ( image -- )
   >r   pm-identity   glOrtho(  -0.5e   r@ ->image-w @ s>f -0.5e f+  -0.45e  r> ->image-h @ s>f -0.45e f+  1024e -1024e )   true to 2dmode?  mv-identity ;

: unbind-framebuffer ( -- )
   glPopAttrib
   unbind-fbo ;

:[] offscreen:[  ( image xt -- )
   over bind-framebuffer execute unbind-framebuffer ;

:[] offscreen2d:[  ( image xt -- )
   over bind-framebuffer over framebuffer-2dmode execute unbind-framebuffer ;

\ =========================================================
\ Init/Shutdown

: init-images
   Images climb:[
      dup  ->source-image @  if
         init-image
      else
         dup  ->image-w 2v@  sdl-new  swap  ->surface !
      then
   ;] ;

: init-textures
   Images climb:[ init-texture ;] ;

: free-images
   Images climb:[ free-image ;] ;

:onload
   cr ." Initializing surfaces...
   init-images ;
:prune
   cr ." Freeing surfaces...
   free-images ;

\ =========================================================
\ Instantiation


: Image,  ( w h -- )
   here >r /Image /allot
   2dup
   sdl-new r@ ->surface !
   r@ ->image-w 2v!
   r> Images add-child ;

: Image:  ( w h -- <name> )
   create image, ;

: Graphic:  ( filename count -- <name> )
   here >r cache-file,
   0 0 Image:
   r> lastbody ->source-image !
   lastbody init-image ;

\ Misc

: pixel[]  ( image x y -- addr )
   2>r ->surface @ 2r> sdl-pixel ;

